home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / fontsel.tcl.z / fontsel.tcl
Text File  |  2002-07-08  |  11KB  |  407 lines
  1. # Font selection interface
  2. # Font chapter
  3.  
  4. proc Font_Dialog {} {
  5.     # The menus are big, so position the window
  6.     # near the upper-left corner of the display
  7.     global font fontreslist
  8.  
  9.     set t .fontsel
  10.     if [Exwin_Toplevel .fontsel "Font Selection"] {
  11.  
  12.     $t.but.quit config -command Font_Dismiss
  13.  
  14.     button $t.but.reset -text "Clear Current" -command Font_Reset
  15.     pack $t.but.reset -side right
  16.  
  17.     button $t.but.help -text "Help" -command {Help Font "Font Help"}
  18.     pack $t.but.help -side right
  19.  
  20.     menubutton $t.but.widgets -text "Widget..." -menu $t.but.widgets.m
  21.     set m [menu $t.but.widgets.m]
  22.  
  23.     set fontreslist {
  24.         *font
  25.         *Button.font
  26.         *Entry.font    
  27.         *Label.font    
  28.         *Message.font
  29.         *Listbox.font
  30.         *Text.font    
  31.         *fl_font    
  32.         *Ftoc*Text.font
  33.         *Msg*Text.font
  34.         *Sedit*Text.font
  35.     } 
  36.     foreach resource $fontreslist {
  37.         $m add command -label $resource -command "FontSetResource $resource \$font(current)"
  38.     }
  39.     pack $t.but.widgets -side left
  40.     button $t.but.save -text "Save" -command Font_Save
  41.     pack $t.but.save -side left
  42.  
  43.     button $t.but.clear -text "Reset All" -command Font_Clear
  44.     pack $t.but.clear -side left
  45.  
  46.     label $t.but.warning -text "Listing Fonts..."
  47.     pack $t.but.warning -side left
  48.     
  49.     # Set up a set of menus.  There is one for each
  50.     # component of a font name, except that the two resolutions
  51.     # are combined and the avgWidth is supressed.
  52.     frame $t.menubar
  53.     option add *$t.menubar*highlightThickness 0
  54.     set font(comps) {foundry family weight slant swidth \
  55.         adstyle pixels points res res2 \
  56.         space avgWidth registry encoding}
  57.     foreach x $font(comps) {
  58.         # font lists all possible component values
  59.         # current keeps the current component values
  60.         set font(cur,$x) *
  61.         set font($x) {}
  62.         # Trim out the second resolution and the average width
  63.         if {$x == "res2" || $x == "avgWidth"} {
  64.             continue
  65.         }
  66.         # The border and highlight thickness are set to 0 so the 
  67.         # button texts run together into one long string.
  68.         menubutton $t.menubar.$x -menu $t.menubar.$x.m -text -$x \
  69.             -padx 0 -bd 0 -font fixed
  70.         menu $t.menubar.$x.m
  71.         pack $t.menubar.$x -side left
  72.         # Create the initial wild card entry for the component
  73.         $t.menubar.$x.m add radio -label * \
  74.             -variable font(cur,$x) \
  75.             -value * \
  76.             -command [list FontList]
  77.     }
  78.     # Use traces to patch up the supressed font(comps)
  79.     trace variable font(cur,res2) r FontTraceRes2
  80.     trace variable font(cur,avgWidth) r FontTraceWidth
  81.     # Mostly, but not always, the points are 10x the pixels
  82.     trace variable font(cur,pixels) w FontTracePixels
  83.     
  84.     # Create a listbox to hold all the font names
  85.     frame $t.body
  86.     set font(list) [listbox $t.body.list \
  87.         -setgrid true  \
  88.         -yscrollcommand "$t.body.scroll set"]
  89.     $font(list) config -selectmode browse
  90.     scrollbar $t.body.scroll -command "$t.body.list yview"
  91.     pack $t.body.scroll -side right -fill y
  92.     pack $t.body.list -side left -fill both -expand true
  93.     
  94.     # Clicking on an item displays the font
  95.     bind $font(list) <ButtonRelease-1> [list FontSelect $font(list) %y]
  96.       # This label displays the current font
  97.     label $t.font -textvar font(current) -bd 5 -font fixed
  98.     # A message displays a string in the font.
  99.     set font(msg) [message $t.font2 -aspect 1000 -borderwidth 10]
  100.  
  101.     } else {
  102.     # Delete existing menus
  103.     foreach x $font(comps) {
  104.         if {$x == "res2" || $x == "avgWidth"} {
  105.         continue
  106.         }
  107.         set first 1
  108.         catch {set first [$t.menubar.$x.m index {\*}]}
  109.         incr first
  110.         $t.menubar.$x.m delete $first end
  111.     }
  112.     }
  113.     # Save the current font preferences.
  114.     global fontOrig
  115.     foreach line [Preferences_ReadSection "Font Resources" "End Fonts"] {
  116.     if [regexp {^([^:]+): *(.+)$} $line x resource value] {
  117.         set fontOrig($resource) $value
  118.     }
  119.     }
  120.     # Use the xlsfonts program to generate a
  121.     # list of all fonts known to the server.
  122.     $t.but.warning config -text "Querying fonts..."
  123.     Exmh_Status "Listing fonts..."
  124.     if [catch {open "|xlsfonts *"} in] {
  125.         puts stderr "xlsfonts failed $in"
  126.         exit 1
  127.     }
  128.     $t.but.warning config -text ""
  129.     set font(num) 0
  130.     set numAliases 0
  131.     set font(N) 0
  132.     while {[gets $in line] >= 0} {
  133.         $font(list) insert end $line
  134.         # fonts(all,$i) is the master list of existing fonts
  135.         # This is used to avoid potenially expensive
  136.         # searches for fonts on the server, and to
  137.         # highlight the matching font in the listbox
  138.         # when a pattern is specified.
  139.         set font(all,$font(N)) $line
  140.         incr font(N)
  141.     
  142.         set parts [split $line -]
  143.         if {[llength $parts] < 14} {
  144.             # Aliases do not have the full information
  145.             lappend aliases $line
  146.             incr numAliases
  147.         } else {
  148.             incr font(num)
  149.             # Chop up the font name and record the
  150.             # unique font(comps) in the font array.
  151.             # The leading - in font names means that
  152.             # parts has a leading null element and we
  153.             # start at element 1 (not zero).
  154.             set i 1
  155.             foreach x $font(comps) {
  156.                 set value [string trim [lindex $parts $i]]
  157.                 incr i
  158.                 if {[string length $value] &&
  159.                 [lsearch $font($x) $value] < 0} {
  160.                     # Missing this entry, so add it
  161.                     lappend font($x) $value
  162.                 }
  163.             }
  164.         }
  165.     }
  166.     # Fill out the menus
  167.     foreach x $font(comps) {
  168.         if {$x == "res2" || $x == "avgWidth"} {
  169.         continue
  170.         }
  171.         set first 1
  172.         catch {set first [$t.menubar.$x.m index {\*}]}
  173.         incr first
  174.         set last [$t.menubar.$x.m index end]
  175.         if {$last > $first} {
  176.         $t.menubar.$x.m delete $first end
  177.         }
  178.         if {$x == "pixels" || $x == "points"} {
  179.         set vlist [lsort -command FontSizeSort $font($x)]
  180.         } else {
  181.         set vlist [lsort $font($x)]
  182.         }
  183.         foreach value $vlist {
  184.             if {[string length $value] == 0} {
  185.                 set label (nil)
  186.             } else {
  187.                 set label $value
  188.             }
  189.             $t.menubar.$x.m  add radio -label $label \
  190.                 -variable font(cur,$x) \
  191.                 -value $value \
  192.                 -command FontList
  193.         }
  194.     }
  195.     Exmh_Status "Found $font(num) fonts and $numAliases aliases"
  196.     catch {unset fontres}
  197.     
  198.     set font(sampler) "
  199.     ABCDEFGHIJKLMNOPQRSTUVWXYZ
  200.     abcdefghijklmnopqrstuvwxyz
  201.     0123456789
  202.     !@#$%^&*()_+-=[]{};:'\"`~,.<>/?\\|
  203.     "
  204.     set font(errormsg) "
  205.     
  206.     (No matching font)
  207.     
  208.     
  209.     "
  210.     # Now pack the main display
  211.     pack $t.menubar -side top -fill x
  212.     pack $t.body -side top -fill both -expand true
  213.     pack $t.font $font(msg) -side top
  214.  
  215.     Font_Reset
  216. }
  217. proc FontSizeSort {a b} {
  218.     if {[string compare $a $b] == 0} {
  219.     return 0
  220.     }
  221.     if {[string compare $a *] == 0} {
  222.     return -1
  223.     }
  224.     if {[string compare $b *] == 0} {
  225.     return -1
  226.     }
  227.     return [expr $a - $b]
  228. }
  229. proc FontTraceRes2 { args } {
  230.     global font
  231.     set font(cur,res2) $font(cur,res)
  232. }
  233. proc FontTraceWidth { args } {
  234.     global font
  235.     set font(cur,avgWidth) *
  236. }
  237. proc FontTracePixels { args } {
  238.     global font
  239.     catch {
  240.         # Might not be a number
  241.         set font(cur,points) [expr 10*$font(cur,pixels)]
  242.     }
  243. }
  244.  
  245. proc FontList {  } {
  246.     global font
  247.     set font(current) {}
  248.     foreach x $font(comps) {
  249.         append font(current) -$font(cur,$x)
  250.     }
  251.     FontSet
  252. }
  253. proc FontSelect { list y } {
  254.     # Extract a font name from the listbox
  255.     global font
  256.     set ix [$font(list) nearest $y]
  257.     set font(current) [$font(list) get $ix]
  258.     set parts [split $font(current) -]
  259.     if {[llength $parts] < 14} {
  260.         foreach x $font(comps) {
  261.             set font(cur,$x) {}
  262.         }
  263.     } else {
  264.         set i 1
  265.         foreach x $font(comps) {
  266.             set value [lindex $parts $i]
  267.             incr i
  268.             set font(cur,$x) $value
  269.         }
  270.     }
  271.     FontSet
  272. }
  273. proc FontSet {} {
  274.     global font
  275.     # Generate a regular expresson from the font pattern
  276.     regsub -all -- {\(nil\)} $font(current) {} font(current)
  277.     regsub -all -- {\*} $font(current) {[^-]*} pattern
  278.     for {set n 0} {$n < $font(N)} {incr n} {
  279.         if [regexp -- $pattern $font(all,$n)] {
  280.             if ![catch {
  281.             $font(msg) config -font $font(current) \
  282.                 -text $font(sampler)
  283.             }] {
  284.                 catch {$font(list) select clear \
  285.                     [$font(list) curselection]}
  286.                 $font(list) select set $n
  287.                 $font(list) see $n
  288.                 return
  289.             }
  290.         }
  291.     }
  292.     $font(msg) config -text $font(errormsg)
  293. }
  294.  
  295. proc Font_Reset {} {
  296.     global font
  297.     foreach x $font(comps) {
  298.         set font(cur,$x) *
  299.     }
  300.     FontList
  301.     Exmh_Status "$font(num) fonts"
  302. }
  303.  
  304. proc FontSetResource {resource {value fixed} {whom .} {classlist {}}} {
  305.     global fontres
  306.     # Special case folder display labels with their pseudo-resource
  307.     if [regexp {^(\*fl_font|\*font)$} $resource] {
  308.     global fdisp
  309.     set fdisp(font) $value 
  310.     set fontres(*fl_font) $value
  311.     if [regexp {^(\*fl_font)$} $resource] {
  312.         return
  313.     }
  314.     }
  315.     set reslist [split $resource .*]
  316.     set n [llength $reslist] ; incr n -1
  317.     set attr [lindex $reslist $n] ; incr n -1
  318.     set newlist {}
  319.     foreach r [lrange $reslist 1 $n] {
  320.     lappend newlist [string tolower $r]
  321.     }
  322.     .fontsel.but.warning config -text "Setting font..."
  323.     FontSetResourceInner $attr $resource $newlist $value $whom $classlist
  324.     .fontsel.but.warning config -text ""
  325.  
  326. }
  327. proc FontSetResourceInner {attr resource reslist value whom classlist} {
  328.     global font fontres
  329.  
  330.     lappend classlist [string tolower [winfo class $whom]]
  331. #    Exmh_Status "$attr: $reslist $whom $classlist"
  332.  
  333.     set hit 1
  334.     foreach class $reslist {
  335.     if {[lsearch -glob $classlist *$class] < 0} {
  336.         set hit 0
  337.         break
  338.     }
  339.     }
  340.     if {$hit} {
  341.     Exmh_Status "$whom => $value"
  342.     catch {
  343.         $whom config -[string tolower $attr] $value
  344.         option add $resource $value
  345.         set fontres($resource) $value
  346.         if {$resource == "*Button.font"} {
  347.         foreach r {Menubutton Checkbutton Radiobutton Menu} {
  348.             option add *$r.font $value
  349.             set fontres(*$r.font) $value
  350.         }
  351.         }
  352.     }
  353.     }
  354.     foreach child [winfo children $whom] {
  355.     FontSetResourceInner $attr $resource $reslist $value $child $classlist
  356.     }
  357. }
  358. proc Font_Save {} {
  359.     global font fontres fontreslist fontOrig
  360.     foreach resource [concat $fontreslist *Menubutton.font *Checkbutton.font *Radiobutton.font *Menu.font] {
  361.     if [info exists fontres($resource)] {
  362.         set fontOrig($resource) $fontres($resource)
  363.     }
  364.     if [info exists fontOrig($resource)] {
  365.         lappend newstuff [format "%s\t%s" ${resource}: $fontOrig($resource)]
  366.     }
  367.     }
  368.     if [info exists newstuff] {
  369.     Preferences_RewriteSection "Font Resources" "End Fonts" $newstuff
  370.     catch {unset fontres}
  371.     }
  372. }
  373. proc Font_Clear {} { 
  374.     global font fontres fontreslist fontOrig exmh
  375.     Preferences_RewriteSection "Font Resources" "End Fonts" {}
  376.     catch {unset fontres}
  377.     catch {unset fontOrig}
  378.     Preferences_Reset
  379.     foreach child [winfo children .] {
  380.     FontClear $child
  381.     }
  382.     global fdisp
  383.     set fdispFont [option get . fl_font {}]
  384.     if [catch { set fdisp(font) $fdispFont} ] {    ;# error in trace proc
  385.     set fdisp(font) fixed
  386.     }
  387. }
  388. proc FontClear {w} {
  389.     set default [option get $w font {}]
  390.     if {[string length $default] == 0} {
  391.     catch {lindex [$w config -font] 3} default
  392.     }
  393.     if [catch {$w config -font $default}] {
  394.     catch {$w config -font fixed}
  395.     }
  396.     foreach child [winfo children $w] {
  397.     FontClear $child
  398.     }
  399. }
  400. proc Font_Dismiss {} {
  401.     global fontres
  402.     if [info exists fontres] {
  403.     Font_Save 
  404.     }
  405.     Exwin_Dismiss .fontsel
  406. }
  407.